home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d3
/
db4less3.arc
/
CUSTOMER.PRG
< prev
next >
Wrap
Text File
|
1990-06-16
|
16KB
|
528 lines
********************************************************************************
* Program......: CUSTOMER
* Author.......: Bruce Troutman
* Date.........: 12-04-88
* Notice.......: Type information here or greetings to your users.
* dBASE Ver....: See Application menu to use as sign-on banner.
* Generated by.: APGEN version 1.0
* Description..: Customer Names and Addresses Manager
* Notes........:
********************************************************************************
SET CONSOLE OFF
IF TYPE("gn_apgen") = "U" && We were not called from another APGEN program
CLEAR ALL
CLEAR WINDOW
CLOSE ALL
gn_apgen = 1
ELSE
gn_apgen = gn_apgen + 1
PRIVATE gc_bell, gc_carry, gc_clock, gc_century, gc_confirm, gc_deli,;
gc_escape, gc_instruc, gc_safety, gc_status, gc_score, gc_talk
ENDIF
*-- Window for pause message box (ON ERROR)
DEFINE WINDOW Pause FROM 15,00 TO 19,79 DOUBLE
ON ERROR DO PAUSE WITH [Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()
ON KEY LABEL F1 DO quickhlp
*-- Store initial SETs to variables
gc_bell =SET("BELL")
gc_carry =SET("CARRY")
gc_clock =SET("CLOCK")
gc_century=SET("CENTURY")
gc_confirm=SET("CONFIRM")
gc_deli =SET("DELIMITERS")
gc_escape =SET("ESCAPE")
gc_instruc=SET("INSTRUCT")
gc_safety =SET("SAFETY")
gc_status =SET("STATUS")
gc_score =SET("SCOREBOARD")
gc_talk =SET("TALK")
SET CLOCK OFF
SET COLOR TO
CLEAR
SET CONSOLE ON
*-- Sets for application
SET BELL ON
SET CARRY OFF
SET CENTURY OFF
SET CONFIRM OFF
SET DELIMITERS TO ""
SET DELIMITER OFF
SET ESCAPE ON
***SET INSTRUCT OFF ** remove for RunTime
SET SAFETY ON
SET SCOREBOARD OFF
SET STATUS OFF
SET TALK OFF
*-- Set global variables
gn_barv = 0 && Initialize bar value variable
gn_error = 0 && Variable to store error() number
gn_send = 0 && Return variable from popup
gc_brdr = "2" && Border style for menu box - See Procedure
lc_heading = "Customer File Manager" && Menu heading string
ll_color = ISCOLOR()
CLEAR
SET ESCAPE ON
SET STATUS ON
*-- Set colors
IF ll_color
SET COLOR OF NORMAL TO w+/b
SET COLOR OF MESSAGES TO w+/n
SET COLOR OF TITLES TO w/b
SET COLOR OF HIGHLIGHT TO b/w
SET COLOR OF BOX TO b/w
SET COLOR OF INFORMATION TO b/w
SET COLOR OF FIELDS TO b/w
ENDIF
USE CUSTOMER INDEX CUSTOMER
SET ORDER TO CUSTNAME
*-- Define the main popup menu for Quickapp
SET BORDER TO DOUBLE
DEFINE POPUP quick FROM 7,27
DEFINE BAR 1 OF quick PROMPT " Add Information" MESSAGE "Add records to database CUSTOMER"
DEFINE BAR 2 OF quick PROMPT " Change Information" MESSAGE "Edit records in database CUSTOMER"
DEFINE BAR 3 OF quick PROMPT " Browse Information" MESSAGE "Browse database CUSTOMER"
DEFINE BAR 4 OF quick PROMPT " Discard Marked Records " MESSAGE "Purge deleted records in database CUSTOMER"
DEFINE BAR 5 OF quick PROMPT " Print Report" MESSAGE "Run report form CUSTOMER"
DEFINE BAR 6 OF quick PROMPT " Mailing Labels" MESSAGE "Run label form CUSTOMER"
DEFINE BAR 7 OF quick PROMPT " Reindex Database" MESSAGE "Reindex database CUSTOMER"
DEFINE BAR 8 OF quick PROMPT " Exit From Customer" MESSAGE "Exit program to dBASE"
ON SELECTION POPUP quick DO Action WITH BAR()
*-- Define the popup menu for print redirection
DEFINE POPUP prntchk FROM 10,55
DEFINE BAR 1 OF prntchk PROMPT " Send to..." SKIP
DEFINE BAR 2 OF prntchk PROMPT REPLICATE(CHR(196),14) SKIP
DEFINE BAR 3 OF prntchk PROMPT " Screen " MESSAGE "Screen only"
DEFINE BAR 4 OF prntchk PROMPT " Printer " MESSAGE "Printer LPT1:"
DEFINE BAR 5 OF prntchk PROMPT " Label Sample " MESSAGE "Printer LPT1: with Sample label" SKIP FOR gn_barv <> 6
DEFINE BAR 6 OF prntchk PROMPT " Return" MESSAGE "Return to Main Menu"
ON SELECTION POPUP prntchk DO get_sele
*-- Window to cover work surface during edit, append, etc.
DEFINE WINDOW work FROM 0,0 TO 21,79 NONE
*-- Window for area below menu heading & for running reports/labels in
DEFINE WINDOW desktop FROM 4,0 TO 21,79 NONE
DEFINE WINDOW printemp FROM 10,25 TO 15,56
*-- Display heading centered on the screen.
DO menubox WITH lc_heading
*-- Show the menu so we don't get a flash if the user hits arrow keys or ESC
SHOW POPUP quick
SAVE SCREEN TO quick
*-- Display Quickapp menu centered on the screen.
DO WHILE gn_barv <> 8 && Prevent user from exiting with arrow keys or ESC
ACTIVATE POPUP quick
ENDDO
* Restore SET environment the best we can
SET BELL &gc_bell.
SET CARRY &gc_carry.
SET CLOCK TO
SET CLOCK &gc_clock.
SET CENTURY &gc_century.
SET CONFIRM &gc_confirm.
SET DELIMITERS &gc_deli.
SET ESCAPE &gc_escape.
*** SET INSTRUCT &gc_instruc. ** Remove for RunTime
SET STATUS &gc_status.
SET SAFETY &gc_safety.
SET SCORE &gc_score.
SET TALK &gc_talk.
SET FORMAT TO
IF gn_apgen = 1 && We were not called from another APGEN program
CLEAR WINDOW
CLEAR POPUP
CLEAR ALL
CLOSE ALL
ELSE
RELEASE WINDOWS work, desktop
RELEASE SCREEN quick
RELEASE POPUP quick
gn_apgen = gn_apgen - 1
ENDIF
ON ERROR
ON KEY LABEL F1
RETURN
* EOP: CUSTOMER.PRG
********************************************************************************
* Procedures...: CUSTOMER.Prc
* Author.......: Bruce Troutman
* Date.........: 12-04-88
* Notice.......: Type information here or greetings to your users.
* dBASE Ver....: See Application menu to use as sign-on banner.
* Generated by.: APGEN version 1.0
* Description..: Customer Names and Addresses Manager
* Notes........:
********************************************************************************
*-- Here is a sample procedure file to show the power of procdures.
*-- This example - Menubox displays a menu heading box with a centered heading.
PROCEDURE MenuBox
PARAMETER lc_m_name
*-- Parameter lc_m_name - is the title variable for the menu
SET CLOCK OFF
@ 1,0 FILL TO 2,79 COLOR n/n
DO CASE
CASE gc_brdr = "0"
@ 1,0 CLEAR TO 3,79
CASE gc_brdr = "1"
@ 1,0 TO 3,79
CASE gc_brdr = "2"
lc_color = IIF(ISCOLOR(),"b/w", "W+/N")
@ 1,0 TO 3,79 DOUBLE COLOR &lc_color.
ENDCASE
SET CLOCK TO 2,68
@ 2,1 SAY SUBSTR(CDOW(DATE()),1,3)+'. '+DTOC(DATE())+' '
@ 2,41 - (LEN(lc_m_name)/2) SAY lc_m_name
lc_color = IIF(ISCOLOR(),"w+/b", "W+/N")
@ 2,1 FILL TO 2,78 COLOR &lc_color.
RETURN
PROCEDURE get_sele
*-- Get the user selection & store BAR into variable
gn_send = BAR() && Variable for print testing
DEACTIVATE POPUP
RETURN
PROCEDURE Action
PARAMETERS bar
*-- Get the user selection & store BAR into variable
gn_barv = bar
SET MESSAGE TO
IF LTRIM( STR( gn_barv)) $ "123"
*-- Set format file CUSTOMER for edit/append/browse
SET FORMAT TO CUSTOMER
ENDIF
DO CASE
CASE gn_barv = 1
*-- Add information
SET MESSAGE TO 'Appending records to file CUSTOMER'
APPEND
CASE gn_barv = 2
*-- Change information
SET MESSAGE TO 'Editing file CUSTOMER'
EDIT
CASE gn_barv = 3
*-- Browse information
SET MESSAGE TO 'Browsing file CUSTOMER'
BROWSE FORMAT
CASE gn_barv = 4
*-- Remove information (Pack file customer)
ACTIVATE WINDOW desktop
@ 2,0 SAY "Packing database CUSTOMER to REMOVE records marked for deletion..."
@ 3,0
SET TALK ON
PACK
GO TOP
?
WAIT
SET TALK OFF
DEACTIVATE WINDOW desktop
CASE gn_barv = 5
*-- Run report form customer
SET MESSAGE TO 'Pick an option to locate a record or <ESC> for default'
ACTIVATE WINDOW work
gn_recno = RECNO()
DO position
DEACTIVATE WINDOW work
lc_toprnt = IIF(gn_recno <> recno(),'REST ','')
STORE 0 TO gn_send, gn_pkey
ACTIVATE POPUP prntchk
IF gn_send = 4
lc_toprnt = 'TO PRINT'
ON ERROR DO prntrtry
ENDIF
IF .NOT. gn_send = 6
SET MESSAGE TO 'Printing report CUSTOMER'
ACTIVATE WINDOW desktop
SET ESCAPE ON
REPORT FORM CUSTOMER &lc_toprnt.
IF gn_pkey <> 27
WAIT
ENDIF
SET ESCAPE ON
DEACTIVATE WINDOW desktop
ENDIF
GOTO gn_recno
ON ERROR DO PAUSE WITH [Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()
CASE gn_barv = 6
*-- Run label form customer
SET MESSAGE TO 'Pick an option to locate a record or <ESC> for default'
ACTIVATE WINDOW work
gn_recno = RECNO()
DO position
DEACTIVATE WINDOW work
STORE 0 TO gn_send, gn_pkey
lc_toprnt = IIF(gn_recno <> recno(),'REST ','')
ACTIVATE POPUP prntchk
DO CASE
CASE gn_send = 4
lc_toprnt = 'TO PRINT'
CASE gn_send = 5
lc_toprnt = 'TO PRINT SAMPLE'
ENDCASE
IF .NOT. gn_send = 6
SET MESSAGE TO 'Printing labels'
ACTIVATE WINDOW desktop
SET ESCAPE ON
ON ERROR DO prntrtry
LABEL FORM CUSTOMER &lc_toprnt.
IF gn_pkey <> 27
WAIT
ENDIF
SET ESCAPE ON
DEACTIVATE WINDOW desktop
ENDIF
GOTO gn_recno
ON ERROR DO PAUSE WITH [Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()
CASE gn_barv = 7
*-- Reindex customer
ACTIVATE WINDOW desktop
@ 3,0 SAY "Reindexing database CUSTOMER..."
@ 4,0
SET TALK ON
REINDEX
GO TOP
?
WAIT
SET TALK OFF
DEACTIVATE WINDOW desktop
CASE gn_barv = 8
DEACTIVATE POPUP
ENDCASE
SET MESSAGE TO
IF gc_status = "OFF"
SET STATUS ON
ENDIF
SET FORMAT TO
RESTORE SCREEN FROM quick
RETURN
PROCEDURE Pause
PARAMETER lc_msg
*-- Parameters : lc_msg = message line
IF TYPE("lc_message")="U"
gn_error=ERROR()
ENDIF
lc_msg = lc_msg
lc_option='0'
ACTIVATE WINDOW Pause
IF gn_error > 0
IF TYPE("lc_message")="U"
@ 0,1 SAY [An error has occurred !! - Error message: ]+MESSAGE()
ELSE
@ 0,1 SAY [Error # ]+lc_message
ENDIF
ENDIF
@ 1,1 SAY lc_msg
WAIT " Press any key to continue..."
DEACTIVATE WINDOW Pause
RETURN
PROCEDURE quickhlp
*-- If you want to include help for a quickapp uncomment the lines below and
*-- put your help @ say's into the case statements
*ACTIVATE WINDOW desktop
*CLEAR
DO CASE
CASE BAR() = 1
CASE BAR() = 2
CASE BAR() = 3
CASE BAR() = 4
CASE BAR() = 5
CASE BAR() = 6
CASE BAR() = 7
CASE BAR() = 8
ENDCASE
*WAIT
*DEACTIVATE WINDOW desktop
RETURN
PROCEDURE Position
IF LEN(DBF()) = 0
DO Pause WITH "Database not in use. "
RETURN
ENDIF
SET SPACE ON
SET DELIMITERS OFF
ln_type=0 && sublevel selection
ln_rkey=READKEY() && test for ESC or Return
ln_rec=RECNO() && DBF record number
ln_num=0 && for input of a number
ld_date=DATE() && for input of a date
lc_option='0' && main option ie. Seek, Goto and Locate
*-- Scope ie. ALL, REST, NEXT <n>
STORE SPACE(10) TO lc_scp
*-- 1 = Character SEEK, 2 = For clause, 3 = While clause
STORE SPACE(40) TO lc_ln1, lc_ln2, lc_ln3
lc_temp=""
@ 0,00 SAY "Index order: "+IIF(""=ORDER(),"Database is in natural order",ORDER())
@ 1,00 SAY "Listed below are the first 16 fields."
lc_temp=REPLICATE(CHR(196),19)
@ 2,0 SAY CHR(218)+lc_temp+CHR(194)+lc_temp+CHR(194)+lc_temp+CHR(194)+lc_temp
ln_num=240
DO WHILE ln_num < 560
lc_temp=FIELD( (ln_num-240)/20 +1)
@ (ln_num/80),MOD(ln_num,80) SAY CHR(179)+;
lc_temp+SPACE(11-LEN(lc_temp))+;
SUBSTR("= Char = Date = Logic = Num = Float = Memo ",;
AT(TYPE(lc_temp),"CDLNFMU")*8-7,8)
ln_num=ln_num+20
ENDDO
ln_num=1
DEFINE POPUP Posit1 FROM 8,30
DEFINE BAR 1 OF Posit1 PROMPT " Position by " SKIP
DEFINE BAR 2 OF Posit1 PROMPT REPLICATE(CHR(196),15) SKIP
DEFINE BAR 3 OF Posit1 PROMPT " SEEK Record" MESSAGE "Search on index key" SKIP FOR ""=ORDER()
DEFINE BAR 4 OF Posit1 PROMPT " GOTO Record" MESSAGE "Position to specific record"
DEFINE BAR 5 OF Posit1 PROMPT " LOCATE Record " MESSAGE "Locate record for condition"
DEFINE BAR 6 OF Posit1 PROMPT " Return" MESSAGE "Return without positioning"
ON SELECTION POPUP Posit1 DO get_sele
SET CONFIRM ON
DO WHILE lc_option='0'
ACTIVATE POPUP Posit1
lc_option = ltrim(str(gn_send)) && for popup
IF LASTKEY() = 27 .OR. lc_option="6"
GOTO ln_rec
EXIT
ENDIF
DO CASE
CASE lc_option='3'
*-- Seek
IF LEN(NDX(1))=0 .AND. LEN(MDX(1))=0
DO Pause WITH "Can't use this option - No index files are open."
LOOP
ENDIF
ln_type=1
lc_ln1=SPACE(40)
DEFINE WINDOW Posit2 FROM 8,19 TO 15,62 DOUBLE
ACTIVATE WINDOW Posit2
@ 1,1 SAY "Enter the type of expression:" GET ln_type PICT "#" RANGE 1,3
@ 2,1 SAY "(1=character, 2=numeric and 3=date.)"
READ
IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
SET CONFIRM ON
@ 3,1 SAY "Enter the key expression to search for:"
IF ln_type=3
@ 4,1 GET ld_date PICT "@D"
ELSE
IF ln_type=2
@ 4,1 GET ln_num PICT "##########"
ELSE
@ 4,1 GET lc_ln1
ENDIF
ENDIF
READ
SET CONFIRM OFF
IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
lc_temp=IIF(ln_type=1,"TRIM(lc_ln1)",IIF(ln_type=2,"ln_num","ld_date"))
SEEK &lc_temp.
ENDIF
ENDIF
RELEASE WINDOWS Posit2
CASE lc_option='4'
*-- Goto
ln_type=1
DEFINE POPUP Posit2 FROM 8,30
DEFINE BAR 1 OF Posit2 PROMPT " GOTO:" SKIP
DEFINE BAR 2 OF Posit2 PROMPT REPLICATE(CHR(196),10) SKIP
DEFINE BAR 3 OF Posit2 PROMPT " TOP" MESSAGE "GOTO Top of File"
DEFINE BAR 4 OF Posit2 PROMPT " BOTTOM" MESSAGE "GOTO Bottom of File"
DEFINE BAR 5 OF Posit2 PROMPT " Record # " MESSAGE "GOTO A Specific Record"
ON SELECTION POPUP Posit2 DO get_sele
ACTIVATE POPUP posit2
ln_type = gn_send
IF LASTKEY() <> 27
IF ln_type=5
DEFINE WINDOW Posit2 FROM 8,26 TO 13,50 DOUBLE
ACTIVATE WINDOW Posit2
ln_num=0
@ 3,1 SAY "Max. Record # = "+LTRIM(STR(RECCOUNT()))
@ 1,1 SAY "Record to GOTO" GET ln_num PICT "######" RANGE 1,RECCOUNT()
READ
IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
GOTO ln_num
ENDIF
RELEASE WINDOWS Posit2
ELSE
lc_temp=IIF(ln_type=3,"TOP","BOTTOM")
GOTO &lc_temp.
ENDIF
ENDIF
CASE lc_option='5'
*-- Locate
DEFINE WINDOW Posit2 FROM 8,16 TO 14,66 DOUBLE
ACTIVATE WINDOW Posit2
@ 1,19 SAY "ie. ALL, NEXT <n>, and REST"
@ 1,01 SAY "Scope:" GET lc_scp
@ 2,01 SAY "For: " GET lc_ln2
@ 3,01 SAY "While:" GET lc_ln3
READ
IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
lc_temp=TRIM(lc_scp)
lc_temp=lc_temp + IIF(LEN(TRIM(lc_ln2)) > 0," FOR "+TRIM(lc_ln2),"")
lc_temp=lc_temp + IIF(LEN(TRIM(lc_ln3)) > 0," WHILE "+TRIM(lc_ln3),"")
IF LEN(lc_temp) > 0
LOCATE &lc_temp.
ELSE
DO Pause WITH "All fields were blank."
ENDIF
ENDIF
RELEASE WINDOW Posit2
ENDCASE
IF EOF()
DO Pause WITH "Record not found."
GOTO ln_rec
ENDIF
IF READKEY()=12 .OR. READKEY()= 268 .OR. LASTKEY()=27 && Esc was hit
lc_option='0'
ENDIF
ENDDO
SET DELIMITERS &gc_deli.
SET CONFIRM OFF
RETURN
PROC prntrtry
PRIVATE lc_escape
lc_escape = SET("ESCAPE")
IF .NOT. PRINTSTATUS()
IF lc_escape = "ON"
SET ESCAPE OFF
ENDIF
gn_pkey = 0
ACTIVATE WINDOW printemp
@ 1,0 SAY "Please ready your printer or"
@ 2,0 SAY " press ESC to cancel"
DO WHILE ( .NOT. PRINTSTATUS()) .AND. gn_pkey <> 27
gn_pkey = INKEY()
ENDDO
DEACTIVATE WINDOW printemp
SET ESCAPE &lc_escape
IF gn_pkey <> 27
RETRY
ENDIF
ENDIF
RETURN
* EOF: CUSTOMER.PRG